Hardcore Visual Basic 5.0 (2nd Edition)/Hardcore Visual Basic 5.0 - Second Edition (1997)(Microsoft Press).iso/Code/FUN.FRM

Text File | 1997-06-14 | 19KB | 644 lines

VERSION 5.00
Object = "{35DFF7C3-DEB3-11D0-8C50-00C04FC29CEC}#1.0#0"; "PictureGlass.ocx"
Begin VB.Form FFun
   BorderStyle     =   1  'Fixed Single
   Caption         =   "Fun 'n Games"
   ClientHeight    =   6660
   ClientLeft      =   1908
   ClientTop       =   2076
   ClientWidth     =   6708
   ClipControls    =   0   'False
   FillColor       =   &H00FF00FF&
   BeginProperty Font
      Name            =   "MS Sans Serif"
      Size            =   7.8
      Charset         =   0
      Weight          =   700
      Underline       =   0   'False
      Italic          =   0   'False
      Strikethrough   =   0   'False
   EndProperty
   Icon            =   "fun.frx":0000
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   MinButton       =   0   'False
   ScaleHeight     =   6660
   ScaleWidth      =   6708
   Begin PictureGlass.XPictureGlass pgControl
      Height          =   1095
      Left            =   2400
      TabIndex        =   15
      Top             =   2040
      Width           =   1215
      _ExtentX        =   2138
      _ExtentY        =   1926
      BackColor       =   -2147483628
      BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851}
         Name            =   "MS Sans Serif"
         Size            =   7.8
         Charset         =   0
         Weight          =   700
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      ScaleWidth      =   1215
      ScaleMode       =   0
      ScaleHeight     =   1095
   End
   Begin VB.CommandButton cmdLargeBmp
      Caption         =   "Large"
      Height          =   384
      Left            =   696
      TabIndex        =   14
      Top             =   5688
      Width           =   945
   End
   Begin VB.CommandButton cmdAniBmp
      Caption         =   "Animate"
      Height          =   384
      Left            =   696
      TabIndex        =   13
      Top             =   6168
      Width           =   945
   End
   Begin VB.CommandButton cmdSmallBmp
      Caption         =   "Small"
      Height          =   384
      Left            =   696
      TabIndex        =   12
      Top             =   5196
      Width           =   945
   End
   Begin VB.CheckBox chkAutoRedraw
      Caption         =   "Auto Redraw"
      Height          =   360
      Left            =   4968
      TabIndex        =   11
      Top             =   6228
      Width           =   1575
   End
   Begin VB.CommandButton cmdAnimateCtl
      Caption         =   "Animate &Control"
      Height          =   375
      Left            =   4968
      TabIndex        =   10
      Top             =   1533
      Width           =   1575
   End
   Begin VB.CommandButton cmdSpiralBmp
      Caption         =   "Spiral Bitmap"
      Height          =   375
      Left            =   4968
      TabIndex        =   9
      Top             =   581
      Width           =   1575
   End
   Begin VB.CheckBox chkClip
      Caption         =   "Clip Controls"
      Height          =   468
      Left            =   4968
      TabIndex        =   8
      Top             =   5892
      Value           =   1  'Checked
      Width           =   1575
   End
   Begin VB.CommandButton cmdClear
      Caption         =   "Clear Surface"
      Height          =   375
      Left            =   4968
      TabIndex        =   7
      Top             =   3913
      Width           =   1575
   End
   Begin VB.CommandButton cmdAnimate
      Caption         =   "&Animate Picture"
      Height          =   375
      Left            =   4968
      TabIndex        =   6
      Top             =   1057
      Width           =   1575
   End
   Begin VB.CommandButton cmdStar
      Caption         =   "Stars"
      Height          =   375
      Left            =   4968
      TabIndex        =   5
      Top             =   2009
      Width           =   1575
   End
   Begin VB.CommandButton cmdSort
      Caption         =   "Sort Cards"
      Height          =   375
      Left            =   4968
      TabIndex        =   4
      Top             =   2961
      Width           =   1575
   End
   Begin VB.Timer tmrAnimate
      Enabled         =   0   'False
      Interval        =   10
      Left            =   240
      Top             =   6885
   End
   Begin VB.CommandButton cmdBack
      Caption         =   "Card Backs"
      Height          =   375
      Left            =   4968
      TabIndex        =   3
      Top             =   3437
      Width           =   1575
   End
   Begin VB.CommandButton cmdShuffle
      Caption         =   "Shuffle Cards"
      Height          =   375
      Left            =   4968
      TabIndex        =   2
      Top             =   2485
      Width           =   1575
   End
   Begin VB.CommandButton cmdExit
      Caption         =   "Exit"
      Height          =   375
      Left            =   4968
      TabIndex        =   1
      Top             =   4380
      Width           =   1575
   End
   Begin VB.CommandButton cmdBmpSpiral
      Caption         =   "Bitmap Spiral"
      Height          =   375
      Left            =   4968
      TabIndex        =   0
      Top             =   105
      Width           =   1575
   End
   Begin VB.Label lblMaskColorText
      Caption         =   "Mask Color"
      Height          =   228
      Left            =   5280
      TabIndex        =   19
      Top             =   5664
      Width           =   1032
   End
   Begin VB.Label lblMaskColor
      BackColor       =   &H00FFFFFF&
      BorderStyle     =   1  'Fixed Single
      Height          =   228
      Left            =   4956
      TabIndex        =   18
      Top             =   5664
      Width           =   228
   End
   Begin VB.Label lblFormColor
      BorderStyle     =   1  'Fixed Single
      Height          =   228
      Left            =   4968
      TabIndex        =   17
      Top             =   5316
      Width           =   228
   End
   Begin VB.Label lblFormColorText
      Caption         =   "Form Color"
      Height          =   252
      Left            =   5280
      TabIndex        =   16
      Top             =   5328
      Width           =   1116
   End
   Begin VB.Image imgAniBmp
      BorderStyle     =   1  'Fixed Single
      Height          =   384
      Left            =   120
      Picture         =   "fun.frx":0CFA
      Stretch         =   -1  'True
      Top             =   6168
      Width           =   468
   End
   Begin VB.Image imgLargeBmp
      BorderStyle     =   1  'Fixed Single
      Height          =   384
      Left            =   120
      Picture         =   "fun.frx":10C6
      Stretch         =   -1  'True
      Top             =   5688
      Width           =   456
   End
   Begin VB.Image imgSmallBmp
      BorderStyle     =   1  'Fixed Single
      Height          =   384
      Left            =   120
      Picture         =   "fun.frx":11508
      Stretch         =   -1  'True
      Top             =   5196
      Width           =   456
   End
   Begin VB.Image imgBig
      Height          =   3072
      Left            =   9552
      Picture         =   "fun.frx":1178A
      Top             =   2568
      Visible         =   0   'False
      Width           =   3072
   End
   Begin VB.Image imgLittle
      Height          =   384
      Left            =   12288
      Picture         =   "fun.frx":1980C
      Top             =   1068
      Visible         =   0   'False
      Width           =   384
   End
End
Attribute VB_Name = "FFun"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False

Option Explicit

Private dxCard As Long
Private dyCard As Long

Private xInc As Single, yInc As Single
Private xMove As Single, yMove As Single
Private aCards(0 To 51) As Variant
Private clrMask As Long

Private pgPicture As New CPictureGlass

Enum EAnimateType
    eatNone
    eatCardBacks
    eatPicture
    eatControl
End Enum

Private eatAnimate As EAnimateType

Private WithEvents timerAnimate As CTimer
Attribute timerAnimate.VB_VarHelpID = -1

Private Sub Form_Load()

    ChDir App.Path

    Set timerAnimate = New CTimer
    SetClipControls Me.hWnd, chkClip.Value = vbChecked
    clrMask = vbWhite
    ' Initialize CARDS library and array
    On Error GoTo CardsLoadFail
    If cdtInit(dxCard, dyCard) = 0 Then
        GoTo CardsLoadFail
        cmdShuffle.Enabled = False
        cmdBack.Enabled = False
    Else
        Dim i As Integer
        For i = 0 To 51
            aCards(i) = i
        Next
        ShuffleArray aCards()
    End If
    Exit Sub

CardsLoadFail:
    cmdSort.Enabled = False
    cmdShuffle.Enabled = False
    cmdBack.Enabled = False

End Sub

Private Sub chkClip_Click()
    SetClipControls Me.hWnd, chkClip.Value = vbChecked
End Sub

Private Sub chkAutoRedraw_Click()
    AutoRedraw = (chkAutoRedraw = vbChecked)
End Sub

Private Sub cmdAnimate_Click()
    If cmdAnimate.Caption = "&Animate Picture" Then
        With pgPicture
            ' Draw picture on center of form with white background
            .Create Me, imgAniBmp.Picture, clrMask, Width / 2, Height / 2
            ' Constant controls pace, sign controls direction
            xInc = .Width * 0.05
            yInc = -.Height * 0.05
        End With
        SetTimer eatPicture
        cmdAnimate.Caption = "Stop &Animate"
    Else
        SetTimer eatNone
        cmdAnimate.Caption = "&Animate Picture"
    End If
End Sub

Private Sub cmdAnimateCtl_Click()
    If cmdAnimateCtl.Caption = "Animate &Control" Then
        With pgControl
            Set .Picture = imgAniBmp.Picture
            .MaskColor = clrMask
            .Left = (ScaleWidth / 2) - (.Width / 2)
            .Top = (ScaleHeight / 2) - (.Height / 2)
            ' Constant controls pace, sign controls direction
            xInc = .Width * 0.05
            yInc = -.Height * 0.05
            .Visible = True
        End With
        SetTimer eatControl
        cmdAnimateCtl.Caption = "Stop &Animate"
    Else
        SetTimer eatNone
        cmdAnimateCtl.Caption = "Animate &Control"
    End If
End Sub

Private Sub cmdBack_Click()
    Dim ordScale As Integer
    ordScale = ScaleMode: ScaleMode = vbPixels
    SetTimer eatCardBacks
    Cls
    Dim X As Integer, Y As Integer, ecbBack As ECardBack
    ecbBack = ecbCrossHatch  ' First card back
    ' Draw cards in 4 by 4 grid
    For X = 0 To 3
        For Y = 0 To 3
            cdtDraw Me.hDC, (dxCard * 0.1) + (X * dxCard * 1.1), _
                    (dyCard * 0.1) + (Y * dyCard * 1.1), _
                    ecbBack, ectBacks, QBColor(Random(0, 15))
            ecbBack = ecbBack + 1
        Next
    Next
    ScaleMode = ordScale
End Sub

' Secret undocumented command for animating card backs a click at a time
Private Sub cmdBack_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
    If Button = 2 Then
        Static f As Boolean
        If f = False Then
            cmdBack_Click
            f = True
            SetTimer eatNone
        End If
        AnimateBacks
    End If

End Sub

Private Sub cmdBmpSpiral_Click()
    SetTimer eatNone
    BmpSpiral Me, imgSmallBmp.Picture
    imgSmallBmp.Refresh
    imgLargeBmp.Refresh
    imgAniBmp.Refresh
End Sub

Private Sub cmdSpiralBmp_Click()
    SetTimer eatNone
    Dim X As Long, Y As Long
    X = ((Width - (cmdSpiralBmp.Width * 1.2)) / 2) - (ScaleX(imgLargeBmp.Picture.Width) / 2)
    Y = ((Height - (cmdSpiralBmp.Height * 1.2)) / 2) - (ScaleY(imgLargeBmp.Picture.Height) / 2)
    SpiralBmp Me, imgLargeBmp.Picture, X, Y
End Sub

Private Sub cmdClear_Click()
    SetTimer eatNone
    Cls
End Sub

Private Sub cmdExit_Click()
    Unload Me
End Sub

Private Sub cmdSmallBmp_Click()
    Call FillPicture(imgSmallBmp)
    cmdClear_Click
End Sub

Private Sub cmdLargeBmp_Click()
    Call FillPicture(imgLargeBmp)
    cmdClear_Click
End Sub

Private Sub cmdAniBmp_Click()
    Call FillPicture(imgAniBmp)
    cmdClear_Click
End Sub

Private Sub cmdStar_Click()
    SetTimer eatNone
    Dim i As Integer, xMid As Long, yMid As Long, dxyRadius As Long
    For i = 1 To Random(5, 20)
        dxyRadius = Random(Height / 8, Height / 4)
        xMid = Random(1, Width): yMid = Random(1, Height)
        ' Black border and two random colors
        Star Me, xMid, yMid, dxyRadius, vbBlack, _
             QBColor(Random(1, 15)), QBColor(Random(1, 15))
        ' Black border and one random color
        'Star Me, xMid, yMid, dxyRadius, vbBlack, QBColor (Random(1, 15))
        ' One filled color
        'Star Me, xMid, yMid, dxyRadius, QBColor(Random(1, 15))
    Next
    imgSmallBmp.Refresh
    imgLargeBmp.Refresh
    imgAniBmp.Refresh
End Sub


Private Function FillPicture(pic As Control) As Boolean
    Dim opfile As New COpenPictureFile
    With opfile
        .InitDir = App.Path
        .FilterType = efpBitmap
        .Load Left + (Width * 0.3), Top + (Height * 0.4)
        If .filename <> sEmpty And .picType = vbPicTypeBitmap Then
            pic.Picture = LoadPicture(.filename)
        End If
    End With
End Function

Private Sub cmdShuffle_Click()
    SetTimer eatNone
    Dim ordScale As Integer
    ordScale = ScaleMode: ScaleMode = vbPixels
    ShuffleArray aCards()
    ShowCards aCards()
    ScaleMode = ordScale
End Sub

Private Sub cmdSort_Click()
    SetTimer eatNone
    Dim ordScale As Integer
    ordScale = ScaleMode: ScaleMode = vbPixels
    SortArray aCards(), 0, 51
    ShowCards aCards()
    ScaleMode = ordScale
End Sub

Private Sub Form_Paint()
    If eatAnimate = eatControl Then pgControl.Refresh
End Sub

Private Sub Form_Unload(Cancel As Integer)
    Dim f As Integer
    If cmdSort.Enabled Then cdtTerm
End Sub

Private Sub imgAniBmp_Click()
    cmdAniBmp_Click
End Sub

Private Sub imgLargeBmp_Click()
    cmdLargeBmp_Click
End Sub

Private Sub imgSmallBmp_Click()
    cmdSmallBmp_Click
End Sub

Sub AnimateBacks()
    Static X As Integer, Y As Integer
    Static ecbBack As ECardBack, iState As Integer

    ' Save scale mode and change to pixels
    Dim ordScale As Integer
    ordScale = ScaleMode: ScaleMode = vbPixels

    ' Adjust variables
    If ecbBack < ecbCrossHatch Or ecbBack > ecbO Then
        ecbBack = ecbCrossHatch
        X = 0: Y = 0
    End If
    If X = 4 Then X = 0
    If Y = 4 Then Y = 0: X = X + 1
    Select Case ecbBack
    Case ecbCrossHatch
        ' Change color of crosshatch
        cdtDraw Me.hDC, (dxCard * 0.1) + (X * dxCard * 1.1), _
                (dyCard * 0.1) + (Y * dyCard * 1.1), _
                ecbBack, ectBacks, QBColor(Random(0, 15))
    Case Else 'ecbRobot, ecbCastle, ecbBeach, ecbCardHand
        ' Step through animation states
        If cdtAnimate(Me.hDC, ecbBack, _
                      (dxCard * 0.1) + (X * dxCard * 1.1), _
                      (dyCard * 0.1) + (Y * dyCard * 1.1), iState) Then
            iState = iState + 1
            ScaleMode = ordScale
            Exit Sub    ' Don't move to next card until final state
        End If
        iState = 0
    ' Case Else
        ' Ignore other cards
    End Select
    ' Move to next card
    ecbBack = ecbBack + 1
    Y = Y + 1
    ' Restore
    ScaleMode = ordScale
End Sub

Private Sub AnimatePicture()
    With pgPicture
        If .Left + .Width > ScaleWidth Then xInc = -xInc
        If .Left <= Abs(xInc) Then xInc = -xInc
        If .Top + .Height > ScaleHeight Then yInc = -yInc
        If .Top <= Abs(yInc) Then yInc = -yInc
        .Move .Left + xInc, .Top + yInc
    End With
End Sub

Private Sub AnimateControl()
    With pgControl
        If .Left + .Width > ScaleWidth Then xInc = -xInc
        If .Left <= Abs(xInc) Then xInc = -xInc
        If .Top + .Height > ScaleHeight Then yInc = -yInc
        If .Top <= Abs(yInc) Then yInc = -yInc
        .Move .Left + xInc, .Top + yInc
    End With
End Sub

Private Sub SetTimer(eatAnimateA As Integer)
    eatAnimate = eatAnimateA
    Select Case eatAnimate
    Case eatNone
        timerAnimate.Interval = 0
        ' Hide XPictureGlass object
        pgControl.Visible = False
        cmdAnimate.Caption = "&Animate Picture"
        cmdAnimateCtl.Caption = "Animate &Control"
        ' Remove active CPictureGlass object from memory
        Set pgPicture = Nothing
    Case eatPicture, eatControl
        timerAnimate.Interval = 10
    Case eatCardBacks
        timerAnimate.Interval = 100
    End Select
End Sub

Private Sub ShowCards(aCards() As Variant)
    Dim iSuit As Integer, iCard As Integer

    For iCard = 0 To 12
        For iSuit = 0 To 3
            cdtDraw Me.hDC, (dxCard * 0.3) + (iSuit * dxCard), _
                    (dyCard * 0.1) + iCard * (dyCard / 3.7), _
                    aCards(iSuit + (iCard * 4)), 0, 0&
        Next
    Next
End Sub

Sub SetClipControls(hWnd As Long, f As Boolean)
    ' You want to do this:
    'Me.ClipControls = f
    ' But Visual Basic won't let you; do this instead:
    ChangeStyleBit hWnd, f, WS_CLIPCHILDREN
End Sub

Private Sub lblFormColor_MouseUp(Button As Integer, Shift As Integer, _
                                 X As Single, Y As Single)
    Dim getclr As New CColorPicker
    getclr.Color = lblFormColor.BackColor
    getclr.Load Left + lblFormColor.Left + X, Top + lblFormColor.Top + Y
    lblFormColor.BackColor = getclr.Color
    BackColor = getclr.Color
    chkClip.BackColor = getclr.Color
    chkAutoRedraw.BackColor = getclr.Color
    lblFormColorText.BackColor = getclr.Color
    lblMaskColorText.BackColor = getclr.Color
End Sub

Private Sub lblFormColorText_MouseUp(Button As Integer, Shift As Integer, _
                                     X As Single, Y As Single)
    lblFormColor_MouseUp Button, Shift, X, Y
End Sub

Private Sub lblMaskColor_MouseUp(Button As Integer, Shift As Integer, _
                                 X As Single, Y As Single)
    Dim getclr As New CColorPicker
    getclr.Color = lblMaskColor.BackColor
    getclr.Load Left + lblMaskColor.Left + X, Top + lblMaskColor.Top + Y
    lblMaskColor.BackColor = getclr.Color
    clrMask = getclr.Color
End Sub

Private Sub lblMaskColorText_MouseUp(Button As Integer, Shift As Integer, _
                                     X As Single, Y As Single)
    lblMaskColor_MouseUp Button, Shift, X, Y
End Sub

Private Sub timerAnimate_ThatTime()
    Select Case eatAnimate
    Case eatNone
        Exit Sub
    Case eatCardBacks
        AnimateBacks
    Case eatPicture
        AnimatePicture
    Case eatControl
        AnimateControl
    End Select
End Sub
'